Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume8 / pcmail / part08 < prev next >

Wrap

Text File | 1989-11-03 | 40.2 KB | 1,051 lines

Newsgroups: comp.sources.misc subject: v08i116: pcmail part 08 of 08 From: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Reply-To: markl@oracle.com (Croaker the Physician) Posting-number: Volume 8, Issue 116 Submitted-by: markl@oracle.com (Croaker the Physician) Archive-name: pcmail/part08 Ack when you get the whole thing; then I can post to gnu.emacs telling them they can expect it on c.s.misc in the near future... Thanks, markl #--------------------------------CUT HERE------------------------------------- #! /bin/sh # # This is a shell archive. Save this into a file, edit it # and delete all lines above this comment. Then give this # file to sh by executing the command "sh file". The files # will be extracted into the current directory owned by # you with default permissions. # # The files contained herein are: # # -rw-rw-r-- 1 markl 26267 Oct 31 13:00 pcmailbabyl.el # -rw-rw-r-- 1 markl 12137 Oct 31 11:50 pcmailmail.el # echo 'x - pcmailbabyl.el' if test -f pcmailbabyl.el; then echo 'shar: not overwriting pcmailbabyl.el'; else sed 's/^X//' << '________This_Is_The_END________' > pcmailbabyl.el X;;;; GNU-EMACS PCMAIL mail reader X X;; Written by Mark L. Lambert X;; Architecture Group, Network Products Division X;; Oracle Corporation X;; 20 Davis Dr, X;; Belmont CA, 94002 X;; X;; internet: markl@oracle.com or markl%oracle.com@apple.com X;; UUCP: {hplabs,uunet,apple}!oracle!markl X X;; Copyright (C) 1989 Mark L. Lambert X X;; This file is not officially part of GNU Emacs, but is being X;; donated to the Free Software Foundation. As such, it is X;; subject to the standard GNU-Emacs General Public License, X;; referred to below. X X;; GNU Emacs is distributed in the hope that it will be useful, X;; but WITHOUT ANY WARRANTY. No author or distributor X;; accepts responsibility to anyone for the consequences of using it X;; or for whether it serves any particular purpose or works at all, X;; unless he says so in writing. Refer to the GNU Emacs General Public X;; License for full details. X X;; Everyone is granted permission to copy, modify and redistribute X;; GNU Emacs, but only under the conditions described in the X;; GNU Emacs General Public License. A copy of this license is X;; supposed to have been given to you along with GNU Emacs so you X;; can know your rights and responsibilities. It should be in a X;; file named COPYING. Among other things, the copyright notice X;; and this notice must be preserved on all copies. X X;; NOTE: this is the only code in the pcmail mail reader implementation X;; that understands Babyl. The message format therefore does not X;; matter provided the public entry points all do the expected thing X X;;;; global variables X X;;; system-defined globals X X(defconst pcmail-header-delim "\n\n" X "Mail header delimiter.") X X(defconst pcmail-babyl-begin "\^L" X "Character sequence that begins a Babyl message.") X X(defconst pcmail-babyl-end "\n\^_" X "Character sequence that ends a Babyl message.") X X(defconst pcmail-babyl-exploded-end "^_" X "The character sequence to which we change pcmail-babyl-end when we encounter Xit in the body of a mail message") X X(defconst pcmail-babyl-old-header-delim "*** EOOH ***\n" X "Babyl old header delimiting string.") X X(defconst pcmail-babyl-header X (concat pcmail-babyl-begin "\n0, unseen,,\n" pcmail-babyl-old-header-delim) X "Initial Babyl message header string.") X X(defconst pcmail-babyl-defined-attributes X '("deleted" "forwarded" "filed" "answered" "unseen" "recent" "badheader") X "A list of attributes defined in the Babyl specification") X X(defvar pcmail-uninteresting-fields-regexp nil X "Regexp of headers derived from pcmail-interesting-fields-list.") X X;; Babyl mail drop X X(put 'babyl-mail-drop 'conversion-function 'pcmail-convert-babyl-message) X(put 'babyl-mail-drop 'msg-start-regexp X (concat "BABYL OPTIONS:\\|" pcmail-babyl-begin)) X(put 'babyl-mail-drop 'insert-function 'pcmail-rename-mail-drop) X(put 'babyl-mail-drop 'name-input-func X '(lambda () (pcmail-narrow-read-file-name rmail-file-name))) X X;;;; operations specific to Babyl format X X(defun pcmail-version-information () X "Show useful information about this incarnation of the mail reader. XArgs: none" X (interactive) X (with-output-to-temp-buffer "*pcmail-information*" X (let ((vers)) X (save-excursion X (save-restriction X (pcmail-narrow-to-babyl-header) X (setq vers (or (mail-fetch-field "version") "[unknown]")))) X (princ "Mail reader version:\t") (princ pcmail-version) (terpri) X (princ "Babyl version:\t\t") (princ (or vers "[unknown]")) (terpri) X (princ "Mail directory:\t\t") (princ pcmail-directory) (terpri) X (princ "AutoPigeonholing:\t") X (princ (if pcmail-pigeonhole-hook "enabled\n" "disabled\n")) X (princ "Ignored header fields:\t") X (save-excursion X (set-buffer "*pcmail-information*") X (let ((fill-prefix "\t\t\t") (foo (point))) X (princ (mapconcat 'identity pcmail-uninteresting-fields-list ", ")) X (terpri) X (fill-region-as-paragraph foo (point)))) X (princ "Summary format:\t\t") (princ pcmail-summary-format) (terpri) X (princ "Date format:\t\t") (princ pcmail-date-format) (terpri) X (princ "Folder format:\t\t") X (princ pcmail-folder-mode-line-format) (terpri) X (princ "Startup filter name:\t") (princ pcmail-default-filter-name) X (terpri) X (and (boundp 'pcmail-last-file) X (princ "Default archive file:\t") (princ pcmail-last-file) (terpri)) X (princ "Default wastebasket:\t") X (princ pcmail-wastebasket-folder) (terpri) X (princ "Default printer:\t") (princ pcmail-printer-name) (terpri) X (princ "Default attribute:\t") (princ (or pcmail-last-attr "[none]")) X (terpri) X (princ "Default folder:\t\t") (princ (or pcmail-last-folder "[none]")) X (terpri) X (princ "Default filter name:\t") (princ (or pcmail-last-filter-name X "[none]")) X (terpri) X (princ "Default search regexp:\t") X (princ (or pcmail-last-search "[none]")) (terpri) X (princ "Default addresses:\t") X (princ (or pcmail-last-addresses "[none]")) (terpri) X (princ "Default numeric range:\t") X (princ (cond (pcmail-last-numeric-range X (format "[%d - %d]\n" (nth 0 pcmail-last-numeric-range) X (nth 1 pcmail-last-numeric-range))) X (t "[none]\n"))) X (princ "Default date range:\t") X (princ (cond (pcmail-last-date-range X (format "[%s - %s]\n" X (pcmail-date-triple-to-string X (nth 0 pcmail-last-date-range)) X (pcmail-date-triple-to-string X (nth 1 pcmail-last-date-range)))) X (t "[none]\n"))) X (princ "Yanked-message prefix:\t") X (princ (if (stringp pcmail-yank-prefix) pcmail-yank-prefix "[none]")) X (terpri) X (princ "Highlight forwarded:\t") X (princ (if pcmail-highlight-forwarded-message "yes" "no")) (terpri) X (princ "Yank message on reply:\t") X (princ (if pcmail-yank-message-on-reply "yes" "no")) (terpri) X (princ "Expunge on save:\t") X (princ (if pcmail-expunge-on-save "yes" "no")) (terpri) X (princ "Wastebasket on expunge:\t") X (princ (if pcmail-wastebasket-on-expunge "yes" "no")) (terpri) X (princ "Save on quit:\t\t") X (princ (if pcmail-save-on-quit "yes" "no")) (terpri) X (princ "Delete on archive:\t") X (princ (if pcmail-delete-on-archive "yes" "no")) (terpri) X (princ "Delete on copy:\t\t") X (princ (if pcmail-delete-on-copy "yes" "no")) (terpri) X (princ "Delete on print:\t") X (princ (if pcmail-delete-on-print "yes" "no")) (terpri)))) X X(defun pcmail-undigestify-message () X "Separate a digest message into its constituent messages. XArgs: none X See pcmail-undigestify-message-1. After undigestifying, move to the next Xinteresting message in the folder." X (interactive) X (pcmail-undigestify-message-1 X (pcmail-make-absolute pcmail-current-subset-message)) X (pcmail-next-message)) X X(defun pcmail-undigestify-message-1 (n) X "Separate a digest message into its constituent messages. XArgs: N X If message absolute-numbered N is a UNIX digest, break the digest into its Xconstituent messages, appending the messages to the current folder. XEach undigestified message shares the digest's attribute list." X (let* ((buffer-read-only nil) X (short-dashes (make-string 27 ?-)) X (done) X (digest-name) X (start) (end) X (msg-string (pcmail-message-contents n))) X (save-restriction X (pcmail-narrow-to-unpruned-header n) X (setq digest-name X (mail-strip-quoted-names (or (mail-fetch-field "to") X (mail-fetch-field "reply-to") X (error "Message is not a digest."))))) X (widen) X (goto-char (point-max)) X (setq start (point-marker)) X (insert msg-string) X (setq end (point-max-marker)) X (unwind-protect X (progn X (save-restriction X (narrow-to-region start end) X (goto-char (point-min)) X (cond ((re-search-forward (concat "^" short-dashes "-*\n*" X "End of.*digest.*\n" X "\\**\\(\n------*\\)*") X nil t) X (replace-match "")) X (t X (error "Message is not a digest."))) X (goto-char (point-min)) X (cond ((re-search-forward (concat "^" (make-string 55 ?-) "-*\n*") X nil t) X (delete-region (point-min) (point)) X (insert pcmail-babyl-begin "\n0," X (pcmail-format-babyl-attrs X (aref pcmail-attr-vector n)) X "\n" pcmail-babyl-old-header-delim) X (pcmail-insert-digest-name digest-name)) X (t X (error "Message is not a digest."))) X (while (re-search-forward (concat pcmail-header-delim X short-dashes "-*\n*") X nil t) X (replace-match (concat pcmail-babyl-end pcmail-babyl-begin X "\n0," X (pcmail-format-babyl-attrs X (aref pcmail-attr-vector n)) X "\n" pcmail-babyl-old-header-delim)) X (pcmail-insert-digest-name digest-name)) X (message "Message successfully undigestified") X (setq done t)) X (pcmail-set-message-vectors start) X (pcmail-set-attribute n "undigestified" t) X (pcmail-set-attribute n "deleted" t)) X (or done X (delete-region start end)) X (move-marker start nil) X (move-marker end nil) X (pcmail-narrow-to-message n)))) X X(defun pcmail-insert-digest-name (name) X "Make a To: field in the current message and make NAME its contents. XArgs: (name)" X (save-restriction X (narrow-to-region (point) X (progn (search-forward pcmail-header-delim) X (point))) X (cond ((not (mail-fetch-field "to")) X (goto-char (point-min)) X (re-search-forward "^from:[ \t]*.*\n" nil t) X (insert "To: " name "\n"))))) X X(defun pcmail-toggle-message-header () X "Show original message header of current message if pruned header is now Xshown, or vice versa. XArgs: none" X (interactive) X (pcmail-barf-if-empty-folder) X (let ((n (pcmail-make-absolute pcmail-current-subset-message))) X (cond ((pcmail-header-pruned-p n) X (pcmail-unprune-header n)) X (t X (pcmail-prune-header n))) X (pcmail-narrow-to-message n))) X X;;;; Various utility routines that know about Babyl-formatted messages X X(defun pcmail-make-uninteresting-fields-regexp () X "Make a pruning regexp from the fields in pcmail-uninteresting-fields-list. XArgs: none" X (and pcmail-uninteresting-fields-list X (setq pcmail-uninteresting-fields-regexp X (concat "^" X (mapconcat 'identity pcmail-uninteresting-fields-list X ":\\|^") X ":")))) X X(defun pcmail-unprune-header (n) X "Set message N's header to its original, unpruned state. XArgs: (n) X Delete message absolute-numbered N's pruned header, leaving only the Xunpruned header. Preserve the state of buffer-modified-p; i.e. if it was nil, Xkeep it nil despite our modifications. This saves on disk writes and doesn't Xhurt us since all messages are automatically pruned on display as necessary Xanyway." X (and (not (zerop n)) X (pcmail-header-pruned-p n) X (let ((buffer-read-only nil) X (mod (buffer-modified-p))) X (widen) X (goto-char (pcmail-msgbeg n)) X (forward-line 1) X (delete-char 1) X (insert ?0) X (forward-line 1) X (insert pcmail-babyl-old-header-delim) X (search-forward pcmail-babyl-old-header-delim) X (forward-line -1) X (let ((temp (point))) X (and (search-forward pcmail-header-delim nil t) X (delete-region temp (point)))) X (set-buffer-modified-p mod)))) X X(defun pcmail-prune-header (n) X "Copy message header and prune the copy. XArgs: (n) X Copy message absolute-numbered N's message header, prune it, and place the Xpruned header after the original header line so it will be displayed by Xpcmail-narrow-to-message. Throw away all headers in Xpcmail-uninteresting-fields-list. Leave current buffer narrowed to pruned Xheader. Save the state of buffer-modified-p before pruning and restore Xafterwards. This saves on disk writes and doesn't hurt us since all messages Xare automatically pruned on display as necessary anyway." X (or (zerop n) X (pcmail-header-pruned-p n) X (let ((buffer-read-only nil) X (mod (buffer-modified-p))) X (widen) X (goto-char (pcmail-msgbeg n)) X (forward-line 1) X (delete-char 1) X (insert ?1) X (forward-line 1) X (if (looking-at (regexp-quote pcmail-babyl-old-header-delim)) X (delete-region (point) (progn (forward-line 1) (point)))) X (insert-buffer-substring (current-buffer) X (point) X (save-excursion X (search-forward pcmail-header-delim X (pcmail-msgend n) X 'move) X (point))) X (insert pcmail-babyl-old-header-delim) X (narrow-to-region (point) X (progn X (search-forward pcmail-header-delim X (pcmail-msgend n) t) X (point))) X (pcmail-nuke-uninteresting-fields n) X (set-buffer-modified-p mod)))) X X(defun pcmail-nuke-uninteresting-fields (n) X "Delete all of message N's header fields in pcmail-uninteresting-fields-list. XArgs: (n) X Search for matches for pcmail-uninteresting-fields-regexp, deleting region Xfrom matched text start through possible field continuation lines. Assume Xregion is narrowed to message absolute-numbered N's header." X (or pcmail-uninteresting-fields-regexp X (pcmail-make-uninteresting-fields-regexp)) X (let ((case-fold-search t)) X (goto-char (point-min)) X (while (re-search-forward pcmail-uninteresting-fields-regexp nil t) X (beginning-of-line) X (delete-region (point) X (progn (re-search-forward "\n[^ \t]") X (forward-char -1) X (point))) X (goto-char (point-min))))) X X(defun pcmail-header-pruned-p (n) X "Return T if message absolute-numbered N's header is pruned, NIL else. XArgs: (n)" X (save-excursion X (save-restriction X (widen) X (goto-char (pcmail-msgbeg n)) X (forward-line 1) X (= (following-char) ?1)))) X X(defun pcmail-narrow-to-unpruned-header (n) X "Narrow to the region around message absolute-numbered N's unpruned header. XArgs: (n)" X (widen) X (goto-char (pcmail-msgbeg n)) X (cond ((pcmail-header-pruned-p n) X (forward-line 2) ;skip over attrs X (narrow-to-region (point) X (progn (search-forward X pcmail-babyl-old-header-delim) X (forward-line -1) (point)))) X (t X (forward-line 3) ;skip over attrs, EOOH X (narrow-to-region X (point) X (progn (search-forward pcmail-header-delim X (pcmail-msgend n) 'move) X (point)))))) X X(defun pcmail-narrow-to-message (n) X "Narrow the current buffer to message absolute-numbered N. XArgs: (n) X Narrowed region is message N in a displayable form, i.e. starts with the Xmessage's pruned header and does not include Babyl delimiters, Babyl Xheader information, or unpruned header. If N is 0, narrow to the current Xfolder's Babyl header." X (widen) X (goto-char (pcmail-msgbeg n)) X (cond ((zerop n) X (narrow-to-region (pcmail-msgbeg n) (1- (pcmail-msgend n)))) X (t X (narrow-to-region X (progn (search-forward pcmail-babyl-old-header-delim nil t) (point)) X (- (pcmail-msgend n) 2))))) X X(defun pcmail-narrow-to-field (f) X "Narrow the current buffer to the contents of header field F. XArgs: (f) X Go to the beginning of current narrowed region, search for field F, and Xnarrow to its contents. Assume that the region is already narrowed to a Xmessage header. Return non-NIL if F exists, NIL else." X (let ((start)) X (goto-char (point-min)) X (cond ((re-search-forward (concat "^" (regexp-quote f) ":[ \t]*") X nil t) X (setq start (point)) X (while (progn (forward-line 1) (looking-at "[ \t]"))) X (narrow-to-region start (point)) X (goto-char start) X t)))) X X(defun pcmail-narrow-to-babyl-attrs (&optional n) X "Narrow the current buffer to a message's Babyl attribute list. XArgs: (&optional N) X If N is non-NIL, narrow the current buffer to message absolute-numbered N's XBabyl attribute list, otherwise narrow to the nearest Babyl attribute list Xin the current buffer. Nearest Babyl message is found by searching backward Xthrough the current buffer for the previous message's Babyl message-end Xdelimiter and parsing the attribute list following. If no delimiter Xexists (i.e. point is at the Babyl folder header), return NIL." X (widen) X (let ((found (if n X (goto-char (pcmail-msgbeg n)) X (re-search-backward X (concat pcmail-babyl-end pcmail-babyl-begin) nil t)))) X (and found X (cond ((re-search-forward "[01]," (and n (pcmail-msgend n)) t) X (narrow-to-region (point) (progn (end-of-line) (point))) X (goto-char (point-min))) X (t X (error "Region not Babyl format (narrow-to-babyl-attrs)")))))) X X(defun pcmail-narrow-to-babyl-header () X "Narrow the current buffer to its folder Babyl header. XArgs: none" X (widen) X (goto-char (point-min)) X (narrow-to-region X (point) X (progn (or (re-search-forward pcmail-babyl-end nil t) X (error "Region not Babyl format (narrow-to-babyl-header)")) X (1- (point)))) X (goto-char (point-min))) X X(defun pcmail-insert-babyl-header (mail-drop-list) X "Insert a folder Babyl header at the start of the current buffer. XArgs: (mail-drop-list)" X (goto-char (point-min)) X (insert "BABYL OPTIONS:\nVersion: 5\nLabels: printed, copied, edited, " X "timely, expired, undigestified, precious\n" X (if mail-drop-list X (concat "Mail: " X (mapconcat '(lambda (s) (prin1-to-string s)) X mail-drop-list ", ") X "\n") X "") X "Note: if you can see this, this folder is empty." X pcmail-babyl-end)) X X(defun pcmail-convert-region-to-babyl-format (mail-drop start end) X "Convert region from native mail drop format to Babyl format. XArgs: (mail-drop start end) X Convert the messages between buffer positions START and END from native Xmail drop format to Babyl format. This means installing message-delimiting Xmarkers, creating an attribute list, and adding it to the list of such lists Xmaintained by the calling function. Conversion functions are defined in XMAIL-DROP through the 'conversion-function property. Leave the current Xbuffer narrowed and return the number of messages converted." X (save-excursion X (save-restriction X (narrow-to-region start end) X (goto-char (point-min)) X (let ((case-fold-search t) X (conv-fn (get mail-drop 'conversion-function)) X (msg-start-regexp (get mail-drop 'msg-start-regexp)) X (newmsgs 0)) X (cond ((not conv-fn) X (message "Missing conversion-function property in mail drop %s" X mail-drop) X (ding) X (sit-for 1)) X ((not msg-start-regexp) X (message "Missing msg-start-regexp property in mail drop %s" X mail-drop) X (ding) X (sit-for 1))) X (while (not (eobp)) X (cond ((and conv-fn msg-start-regexp (looking-at msg-start-regexp)) X (funcall conv-fn)) X (t X (pcmail-convert-unknown-message))) X (and (zerop (% (setq newmsgs (1+ newmsgs)) pcmail-progress-interval)) X (message "Checking %s...%d" mail-drop newmsgs)) X (narrow-to-region (point) (point-max))) X newmsgs)))) X X(defun pcmail-scan-babyl-messages (&optional start) X "Scan the current folder buffer, setting up message information. XArgs: (start) X Create attribute list and message marker list for current folder. Put Xmessage-delimiting markers in messages-list, message attributes in Xattr-list, timely message numbers in timely-list, and bump message total Xtotal-messages. Scan from buffer position START to end of buffer." X (let ((msg-attr-list)) X (save-excursion X (save-restriction X (widen) X (goto-char (or start (point-min))) X (while (re-search-forward pcmail-babyl-end nil t) X (setq msg-attr-list (pcmail-make-babyl-attr-list) X attr-list (cons msg-attr-list attr-list) X messages-list (cons (point-marker) messages-list)) X (and (pcmail-in-sequence-p "timely" msg-attr-list) X (setq timely-list (cons total-messages timely-list))) X (and (zerop (% (setq total-messages (1+ total-messages)) X pcmail-progress-interval)) X (message "Counting messages in %s...%d" pcmail-folder-name X total-messages))) X (setq messages-list (nreverse messages-list) X attr-list (nreverse attr-list)))))) X X(defun pcmail-make-babyl-attr-list () X "Return a list of attribute strings from a message's Babyl label list. XArgs: none XCreate an attribute string list from the closest message's Babyl attribute Xinformation. Assume point is at the start of a message's Babyl information. XThis will work on both RMAIL-style and true Babyl-style attribute lists." X (save-excursion X (save-restriction X (and (pcmail-narrow-to-babyl-attrs) X (pcmail-parse-space-list X (buffer-substring (point-min) (point-max))))))) X X(defun pcmail-babyl-defined-attribute-p (attr) X "Return non-NIL if ATTR is a babyl-defined attribute, NIL else." X (pcmail-in-sequence-p attr pcmail-babyl-defined-attributes)) X X(defun pcmail-format-babyl-attrs (l) X "Turn a list of attributes into a Babyl-format label string. XArgs: (attrlist) XGiven a list of attributes, turns it into a Babyl-compatible label string. XThe string is of the form \"( <attr>,)*,( <user-defined-label>,)*\"." X (let ((sys-attrs) (user-attrs)) X (while l X (if (pcmail-babyl-defined-attribute-p (car l)) X (setq sys-attrs (cons (car l) sys-attrs)) X (setq user-attrs (cons (car l) user-attrs))) X (setq l (cdr l))) X X ; now have 2 lists: system attributes and user attributes X ; put them together according to the Babyl specification X (concat X (mapconcat '(lambda (s) (concat " " s ",")) sys-attrs "") X "," X (mapconcat '(lambda (s) (concat " " s ",")) user-attrs "")))) X X(defun pcmail-add-babyl-attr (n attr) X "Add a label to the current message absolute-numbered N's babyl label list. XArgs: (n attr) XIf N is NIL, search backward for the nearest Babyl message, otherwise use Xmessage absolute-numbered N. If ATTR is babyl-defined (i.e. a member of Xthe list pcmail-babyl-defined-attributes), place it at the end of the Xattribute list according to the Babyl specification. Otherwise put it Xat the beginning." X (save-excursion X (save-restriction X (let ((buffer-read-only)) X (pcmail-narrow-to-babyl-attrs n) X (if (pcmail-babyl-defined-attribute-p attr) X (goto-char (point-min)) X (goto-char (point-max))) X (insert " " attr ","))))) X X(defun pcmail-remove-babyl-attr (n attr) X "Remove a label from message absolute-numbered N's babyl label list. XArgs: (n attr) XIf N is NIL, search backward for the nearest Babyl message, otherwise use Xmessage absolute-numbered N. Remove the attribute." X (save-excursion X (save-restriction X (let ((buffer-read-only)) X (pcmail-narrow-to-babyl-attrs n) X (and (re-search-forward (concat " ?" attr ",") nil t) X (delete-region (match-beginning 0) (match-end 0))))))) X X(defun pcmail-babyl-attr-present-p (n attr) X "Return non-NIL if ATTR is present in message absolute-numbered N, NIL else. XArgs: (n attr) XIf N is NIL, narrow to most recent babyl message's babyl label list, Xotherwise narrow to message absolute-numbered N's list. Return non-NIL if XATTR is there, NIL else." X (save-excursion X (save-restriction X (pcmail-narrow-to-babyl-attrs n) X (re-search-forward (concat " ?" attr ",") nil t)))) X X(defun pcmail-user-defined-babyl-attr-list () X "Return the list of non-Babyl-defined attributes in the Labels option Xat the beginning of the current mail file." X (let ((l) (k)) X (save-excursion X (save-restriction) X (pcmail-narrow-to-babyl-header) X (setq l (mail-fetch-field "labels" nil t) X k (mail-fetch-field "keywords" nil t)) ;alt form X (if k (setq l (if l (concat l " " k) k))) X (and l (pcmail-parse-space-list l))))) X X(defun pcmail-insert-user-defined-babyl-attr (attr) X "Insert the user-defined attr ATTR into the current and primary mail files. XArgs: (attr) XIf attr is not already present, insert it into both the current mail file Xand the primary mail file (named pcmail-primary-folder-name). The Babyl Xspecification requires that all user-defined labels in a particular mail Xfile appear in that mail file's labels: option field. We also put the Xattr in the primary mail file's labels: option field so that it gets Xinterned in the attr obarray at mail reader startup." X (pcmail-insert-user-defined-babyl-attr-1 attr pcmail-folder-name) X (pcmail-insert-user-defined-babyl-attr-1 attr pcmail-primary-folder-name) X X ; insert may have screwed up region around current message. Fix it. X (pcmail-narrow-to-message X (pcmail-make-absolute pcmail-current-subset-message))) X X(defun pcmail-insert-user-defined-babyl-attr-1 (attr folder-name) X "Insert the user-defined attr ATTR into mail file FOLDER-NAME. XArgs: (args folder-name) XThis could be made a lot simpler by looking for a labels line and appending Xto it or creating it if it doesn't exist. Instead, we fill labels lines Xwith no more than default-fill-column worth of labels, then create a new Xlabel line. Also, labels are comma-separated with no leading commas." X (save-excursion X (pcmail-open-folder folder-name) X (save-excursion X (save-restriction X (pcmail-narrow-to-babyl-header) X (let ((buffer-read-only) X (labelist) X (label-line-exists) X (label-exists) X (label-null) X (label-start)) X X ; skullduggery to use multiple labels: lines rather than X ; overflow the line. Search for last labels: line X (while (re-search-forward "Labels:[ \t]*" nil t) X (setq label-start (point)) X (and (looking-at "\n") (setq label-null t)) ;no labels here! X (and (re-search-backward attr (prog1 (point) (end-of-line)) t) X (setq label-exists t)) X (setq label-line-exists t)) X X (cond ((not label-exists) ;don't bother if label is already there X X ; if there is a label line, get the last line's contents X (and label-line-exists X (setq labelist X (buffer-substring label-start (point)))) X X ; if there is no label line, or the current one will be too X ; long with the newly-added label, make a new label line, X ; otherwise use the current one X (cond ((or (not label-line-exists) X (> (+ 10 (length attr) (length labelist)) X default-fill-column)) X (goto-char (point-max)) X (insert "Labels: " attr "\n")) X (t X (insert (or label-null ",") " " attr)))))))))) X X(defun pcmail-get-babyl-mail-drop-list () X "Return a list of interned mail drop symbols derived from the names in Xthe current mail file's mail: option field." X (save-excursion X (save-restriction X (pcmail-narrow-to-babyl-header) X (let ((s)) X (setq s (mail-fetch-field "mail")) X (and s X (mapcar '(lambda (x) (intern x)) (pcmail-parse-space-list s))))))) X X(provide 'pcmailbabyl) ________This_Is_The_END________ if test `wc -c < pcmailbabyl.el` -ne 26267; then echo 'shar: pcmailbabyl.el was damaged during transit (should have been 26267 bytes)' fi fi ; : end of overwriting check echo 'x - pcmailmail.el' if test -f pcmailmail.el; then echo 'shar: not overwriting pcmailmail.el'; else sed 's/^X//' << '________This_Is_The_END________' > pcmailmail.el X;;;; GNU-EMACS PCMAIL mail reader X X;; Written by Mark L. Lambert X;; Architecture Group, Network Products Division X;; Oracle Corporation X;; 20 Davis Dr, X;; Belmont CA, 94002 X;; X;; internet: markl@oracle.com or markl%oracle.com@apple.com X;; UUCP: {hplabs,uunet,apple}!oracle!markl X X;; Copyright (C) 1989 Mark L. Lambert X X;; This file is not officially part of GNU Emacs, but is being X;; donated to the Free Software Foundation. As such, it is X;; subject to the standard GNU-Emacs General Public License, X;; referred to below. X X;; GNU Emacs is distributed in the hope that it will be useful, X;; but WITHOUT ANY WARRANTY. No author or distributor X;; accepts responsibility to anyone for the consequences of using it X;; or for whether it serves any particular purpose or works at all, X;; unless he says so in writing. Refer to the GNU Emacs General Public X;; License for full details. X X;; Everyone is granted permission to copy, modify and redistribute X;; GNU Emacs, but only under the conditions described in the X;; GNU Emacs General Public License. A copy of this license is X;; supposed to have been given to you along with GNU Emacs so you X;; can know your rights and responsibilities. It should be in a X;; file named COPYING. Among other things, the copyright notice X;; and this notice must be preserved on all copies. X X;; The following code implements a Pcmail client under GNU-EMACS. For X;; details on how Pcmail works, see NIC RFC-993. X X;;;; global variable definitions X X;;;; pcmail mail composition commands -- compose, forward, reply X X(defun pcmail-mail () X "Compose mail in another window. XArgs: none X Compose mail in another window. Any header parsing can be made Xto conform to NIC RFC-822 by setting the variable mail-use-rfc822 non-NIL." X (interactive) X X ; note the skullduggery here. We need to set the referencing message X ; and folder now because once we call mail-other-window we lose the X ; pcmail local variables. We can't set the referencing variables X ; now because they are local variables defined in X ; pcmail-overlay-mail-commands X (let ((n pcmail-current-subset-message) X (mbox pcmail-folder-name)) X (mail-other-window nil nil nil nil nil (current-buffer)) X (pcmail-overlay-mail-commands nil n mbox))) X X(defun pcmail-answer-message (just-sender) X "Answer the current message. XArgs: (just-sender) X Compose a reply to the current message. Set this message's answered Xattribute. If JUST-SENDER is non-nil (interactively with prefix argument), XDo not include CC: to all other recipients of original message, otherwise Xdo. While composing the reply, use \\[mail-yank-original] to yank the Xoriginal message into it. X XAny header parsing can be made to conform to NIC RFC-822 by setting Xthe variable mail-use-rfc822 non-NIL. X XIf the variable pcmail-yank-original is non-NIL, yank the original Xmessage into the mail buffer." X (interactive "P") X (pcmail-barf-if-empty-folder) X (let ((from) X (reply-to) X (message-id) X (cc) X (subject) X (date) X (to) X (resent-p) X (n (pcmail-make-absolute pcmail-current-subset-message)) X (relnum pcmail-current-subset-message) X (mbox pcmail-folder-name)) X (save-excursion X (save-restriction X (pcmail-narrow-to-unpruned-header n) X (setq to (or (setq resent-p (mail-fetch-field "resent-to" nil t)) X (setq resent-p (mail-fetch-field "resent-apparently-to" X nil t)) ;uck X (mail-fetch-field "to" nil t) X (mail-fetch-field "apparently-to" nil t) ;uck X "")) X (cond (resent-p X (setq from (mail-fetch-field "resent-from") X reply-to (or (mail-fetch-field "resent-reply-to" t) X from) X cc (if just-sender nil (mail-fetch-field "resent-cc" t)) X subject (or (mail-fetch-field "resent-subject" t) X (mail-fetch-field "subject" t)) X date (mail-fetch-field "resent-date" t) X message-id (or (mail-fetch-field "resent-message-id" t) X ""))) X (t X (setq from (mail-fetch-field "from") X reply-to (or (mail-fetch-field "reply-to" t) X from) X cc (if just-sender nil (mail-fetch-field "cc" nil t)) X subject (mail-fetch-field "subject" t) X date (mail-fetch-field "date") X message-id (or (mail-fetch-field "message-id") X "")))))) X X ; if subject was a Re:, strip the Re: since one will be added later X (and subject X (string-match "^[ \t]*\\(re:[ \t]*\\)*\\(.*\\)" subject) X (setq subject (substring subject (match-beginning 2) (match-end 2)))) X X ; and compose the message X (mail-other-window nil X (mail-strip-quoted-names reply-to) X (and subject (concat "Re: " subject)) X (pcmail-make-in-reply-to-field from date message-id) X (cond (just-sender X nil) X (t X (let* ((cc-list (rmail-dont-reply-to X (mail-strip-quoted-names X (if (null cc) to (concat to ", " cc)))))) X (if (string= cc-list "") nil cc-list)))) X (current-buffer)) X (pcmail-overlay-mail-commands 'answered relnum mbox) X (pcmail-maybe-yank-original))) X X(defun pcmail-maybe-yank-original () X "Maybe yank replied-to message into reply body. XArgs: none X If pcmail-yank-message-on-reply is non-NIL, place the replied-to message Xin the message reply. The header is filtered through the Xmail-yank-ignored-headers regexp and is indented. If Xpcmail-yank-message-on-reply is a string, highlight the yanked message Xwith that string at the beginning of each line." X (and pcmail-yank-message-on-reply X (pcmail-insert-current-message nil))) X X(defun pcmail-make-in-reply-to-field (from date message-id) X " Create an in-reply-to field from from:, date:, and message-id: fields. XArgs: (from date message-id)" X (let ((field)) X (and from (setq field (pcmail-quoted-name from))) X (and date (setq field (concat field "'s message of " date))) X (and message-id (setq field (concat field " " message-id))))) X X(defun pcmail-quoted-name (field) X "Return FIELD's quoted name or FIELD if no quoted name exists. XArgs: (field)." X (if (or (string-match "\\(.*\\) *<" field) X (string-match "(\\(.*\\))" field)) X (setq field (substring field (match-beginning 1) (match-end 1))) X field)) X X(defun pcmail-forward-message (dont-clear) X "Forward the current message. XArgs: dont-clear X Set up a forwarded message for editing by the user. Forwarded messages Xare given the forwarded attribute. If called interactively, a prefix Xarg means do not filter the header of the forwarded message prior to insertion Xin the mail composition buffer. If pcmail-highlight-forwarded-message Xis non-NIL, put highlight lines at the beginning and end of the forwarded Xtext. Any header parsing can be made to conform to NIC RFC-822 by setting Xthe variable mail-use-rfc822 non-NIL." X (interactive "P") X (pcmail-barf-if-empty-folder) X (let ((forward-buffer (current-buffer)) X (start) (subject (mail-fetch-field "subject")) X (forwarded-from) X (n pcmail-current-subset-message) X (mbox pcmail-folder-name)) X X ; if subject was of a forwarded message, strip the subject portion to X ; avoid cascaded [foo: [foo: [foo: ...]]] nightmares X (and subject X (let ((match) (lastgood)) X (while (setq match (string-match "\\[.*: " subject lastgood)) X (setq lastgood (match-end 0))) X (and lastgood X (setq subject (substring subject lastgood)) X (and (setq match (string-match "\\]+" subject)) X (setq subject (substring subject 0 match)))))) X (setq forwarded-from (mail-strip-quoted-names (mail-fetch-field "From"))) X (mail nil nil X (if subject X (format "[%s: %s]" forwarded-from subject) X (format "[message from %s]" forwarded-from)) X nil nil (current-buffer)) X (save-excursion X (goto-char (point-max)) X (forward-line 1) X (and pcmail-highlight-forwarded-message X (insert "\n---Begin Forwarded Message---\n\n")) X (setq start (point)) X (insert-buffer forward-buffer) X (or dont-clear (mail-yank-clear-headers start (mark))) X (goto-char (point-max)) X (and pcmail-highlight-forwarded-message X (insert "\n\n---End Forwarded Message---\n"))) X (pcmail-overlay-mail-commands 'forwarded n mbox))) X X(defun pcmail-overlay-mail-commands (type relnum mbox) X "Overlay standard mail functions with augmented pcmail functions. XArgs: (type relnum mbox) X Also set local variables which will tell the mail-send routine whether Xor not to set referencing message attributes on send." X (make-local-variable 'pcmail-referencing-message-type) X (setq pcmail-referencing-message-type type) X (make-local-variable 'pcmail-referencing-message-rel-number) X (setq pcmail-referencing-message-rel-number relnum) X (make-local-variable 'pcmail-referencing-message-folder) X (setq pcmail-referencing-message-folder mbox) X (define-key mail-mode-map "\C-c\C-y" 'pcmail-insert-current-message) X (define-key mail-mode-map "\C-c\C-c" 'pcmail-mail-send-and-exit) X (define-key mail-mode-map "\C-c\C-s" 'pcmail-mail-send)) X X(defun pcmail-mail-send-and-exit (arg) X "Like mail-send-and-exit, but sensitive to the other buffer being Xpcmail-mode rather than rmail-mode." X (interactive "P") X (pcmail-mail-send) X (bury-buffer (current-buffer)) X (if (and (not arg) X (not (one-window-p)) X (save-excursion X (set-buffer (window-buffer (next-window (selected-window) 'not))) X (eq major-mode 'pcmail-folder-mode))) X (delete-window) X (switch-to-buffer (other-buffer (current-buffer))))) X X(defun pcmail-mail-send () X "Like mail-send, but also sets labels of referencing message as necessary. XArgs: none X Calls mail-send. If successful, sets the forwarded/answered labels of Xthe message that this message references." X (interactive) X (let ((type pcmail-referencing-message-type) X (rel-n pcmail-referencing-message-rel-number) X (n) X (mbox pcmail-referencing-message-folder)) X (mail-send) X X ; if the message to be sent is forwarded or replied-to, set the X ; forwarded or replied-to message's forwarded/answered attributes X (and mail-reply-buffer X type X rel-n X mbox X (pcmail-find-folder mbox) X (save-excursion X (save-restriction X (pcmail-open-folder mbox) X (setq n (pcmail-make-absolute rel-n)) X (pcmail-narrow-to-message n) X (cond ((eq type 'forwarded) X (pcmail-set-attribute n "forwarded" t) X (pcmail-update-folder-mode-line rel-n)) X ((eq type 'answered) X (pcmail-set-attribute n "answered" t) X (pcmail-update-folder-mode-line rel-n)))))))) X X(defun pcmail-insert-current-message (n) X "Insert the current folder's current message into an outbound message. XArgs: (n) X Insert the current message into the message composition buffer and filter Xits header according to mail-yank-ignored-headers. With a Xprefix argument N, insert the Nth message in the current subset. If N Xis negative, don't filter the inserted message's header." X (interactive "P") X (let ((nostrip) (folderbuf) (msgbuf (current-buffer))) X (if (or (null n) X (zerop n)) X (setq n pcmail-referencing-message-rel-number)) X (and n X (save-excursion X (if (< n 0) X (setq nostrip t X n (- n))) X (cond ((pcmail-find-folder pcmail-referencing-message-folder) X (pcmail-open-folder pcmail-referencing-message-folder) X (save-excursion X (save-restriction X (setq n (pcmail-make-absolute n)) X (cond ((<= n pcmail-total-messages) X (pcmail-narrow-to-message n) X (setq folderbuf (current-buffer)) X (delete-windows-on folderbuf) X (set-buffer msgbuf) X (let ((start (point))) X (insert-buffer folderbuf) X (or nostrip X (run-hooks X (if (boundp 'mail-yank-hooks) X 'mail-yank-hooks X 'pcmail-default-mail-yank-hook))) X (exchange-point-and-mark) X (or (eolp) X (insert ?\n))))))))))))) X X;;; yank-message hook, for use with supercite package. Default hook assumes X;;; no supercite capability X X(setq pcmail-default-mail-yank-hook X '(lambda () X (mail-yank-clear-headers start (mark)) X (indent-rigidly start (mark) 3) X (and (stringp pcmail-yank-prefix) X (while (re-search-forward "^" nil t) X (replace-match pcmail-yank-prefix) X (forward-line 1))))) X X(provide 'pcmailmail) ________This_Is_The_END________ if test `wc -c < pcmailmail.el` -ne 12137; then echo 'shar: pcmailmail.el was damaged during transit (should have been 12137 bytes)' fi fi ; : end of overwriting check exit 0